home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Mindy / Mindy 1.2 - portable sources / interp / table.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-03-15  |  7.7 KB  |  272 lines  |  [TEXT/ttxt]
  1. /**********************************************************************\
  2. *
  3. *  Copyright (c) 1994  Carnegie Mellon University
  4. *  All rights reserved.
  5. *  
  6. *  Use and copying of this software and preparation of derivative
  7. *  works based on this software are permitted, including commercial
  8. *  use, provided that the following conditions are observed:
  9. *  
  10. *  1. This copyright notice must be retained in full on any copies
  11. *     and on appropriate parts of any derivative works.
  12. *  2. Documentation (paper or online) accompanying any system that
  13. *     incorporates this software, or any part of it, must acknowledge
  14. *     the contribution of the Gwydion Project at Carnegie Mellon
  15. *     University.
  16. *  
  17. *  This software is made available "as is".  Neither the authors nor
  18. *  Carnegie Mellon University make any warranty about the software,
  19. *  its performance, or its conformity to any specification.
  20. *  
  21. *  Bug reports, questions, comments, and suggestions should be sent by
  22. *  E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  23. *
  24. ***********************************************************************
  25. *
  26. * $Header: table.c,v 1.12 94/11/03 22:19:32 rgs Locked $
  27. *
  28. * This file implements support for <table>. Specifically, that means
  29. * writing object-hash and merge-hash-codes, and defining
  30. * $permanent-hash-state. As an extension for <equal-table> and 
  31. * <value-table>, float-hash has been included for hashing floating point
  32. * numbers without using object-hash.
  33. *
  34. \**********************************************************************/
  35.  
  36. #include "../compat/std-c.h"
  37.  
  38. #include "mindy.h"
  39. #include "thread.h"
  40. #include "func.h"
  41. #include "def.h"
  42. #include "list.h"
  43. #include "bool.h"
  44. #include "num.h"
  45. #include "obj.h"
  46. #include "sym.h"
  47. #include "gc.h"
  48. #include "class.h"
  49. #include "print.h"
  50. #include "table.h"
  51.  
  52. struct hash_state {
  53.     obj_t class;
  54. };
  55.  
  56. static obj_t obj_HashStateClass = NULL;
  57. static obj_t permanent_state = NULL;
  58. static obj_t valid_state = NULL;
  59.  
  60. /* object-hash returns $permanent-hash-state for all <number>s implemented
  61.  * in Mindy. Basically, it's implemented by a series of if's: fixnum?
  62.  * single_float? double_float? extended_float? If any of those, return an
  63.  * appropriate value along with $permanent-hash-state. Otherwise, hash
  64.  * the pointer and return a non-permanent hash state.
  65.  *
  66.  * Floats are hashed in a non-portable way: By using & on the C
  67.  * representation of the floating point number (along with some type
  68.  * coercision to keep the warnings to a minimum).
  69.  * (see also float-hash)
  70.  */
  71.  
  72. static void dylan_object_hash(struct thread *thread, int nargs)
  73. {
  74.     obj_t *old_sp = thread->sp - 2;
  75.     obj_t object = old_sp[1];
  76.     obj_t class;
  77.  
  78.     assert(nargs == 1);
  79.  
  80.     if (obj_is_fixnum(object)) {
  81.         old_sp[0] = (obj_t)(((unsigned long)MAX_FIXNUM)
  82.                     & ((unsigned long)object));
  83.     old_sp[1] = permanent_state;
  84.     }
  85.     else {
  86.         class = obj_ptr(struct object *, object)->class;
  87.         if (class == obj_SingleFloatClass) {
  88.             old_sp[0] = (obj_t)(((unsigned long)MAX_FIXNUM)
  89.                 & (*((int *)(&single_value(object)))));
  90.                 /* Pretend the float is really an
  91.                    integer so we can get at its bits */
  92.         old_sp[1] = permanent_state;
  93.     }
  94.         else if (class == obj_DoubleFloatClass) {
  95.             old_sp[0] = (obj_t)(((unsigned long)MAX_FIXNUM)
  96.                 & (*((int *)(&double_value(object)))));
  97.                 /* Pretend the float is really an
  98.                    integer so we can get at its bits */
  99.         old_sp[1] = permanent_state;
  100.     }
  101.         else if (class == obj_ExtendedFloatClass) {
  102.             old_sp[0] = (obj_t)(((unsigned long)MAX_FIXNUM)
  103.                 & (*((int *)(&extended_value(object)))));
  104.                 /* Pretend the float is really an
  105.                    integer so we can get at its bits */
  106.         old_sp[1] = permanent_state;
  107.     }
  108.     else {            /* Hash the pointer itself */
  109.             old_sp[0] = (obj_t)(((unsigned long)MAX_FIXNUM)
  110.                        & ((unsigned long)object));
  111.  
  112.         if (valid_state == obj_False)
  113.            valid_state = alloc(obj_HashStateClass, 
  114.                                    sizeof(struct hash_state));
  115.         old_sp[1] = valid_state;
  116.     }
  117.     }
  118.  
  119.     do_return(thread, old_sp, old_sp);
  120. }
  121.  
  122. static obj_t dylan_state_valid_p(obj_t state)
  123. {
  124.     if (state == permanent_state || state == valid_state)
  125.     return obj_True;
  126.     else
  127.     return obj_False;
  128. }
  129.  
  130. static void dylan_merge_hash_codes(obj_t self, struct thread *thread,
  131.                    obj_t *args)
  132. {
  133.     unsigned long id1 = fixnum_value(args[0]);
  134.     obj_t state1 = args[1];
  135.     unsigned long id2 = fixnum_value(args[2]);
  136.     obj_t state2 = args[3];
  137.     obj_t ordered = args[4];
  138.     obj_t *old_sp = args-1;
  139.  
  140.     if (ordered != obj_False)
  141.     id2 = (id2 << 5) | (id2 >> (sizeof(long)*CHAR_BIT-5));
  142.     old_sp[0] = make_fixnum(id1 ^ id2);
  143.  
  144.     if (state1 == permanent_state)
  145.     old_sp[1] = state2;
  146.     else if (state2 == permanent_state)
  147.     old_sp[1] = state1;
  148.     else if (state1 == valid_state)
  149.     old_sp[1] = state2;
  150.     else
  151.     old_sp[1] = state1;
  152.  
  153.     thread->sp = old_sp + 2;
  154.     do_return(thread, old_sp, old_sp);
  155. }
  156.  
  157. static void dylan_float_hash(struct thread *thread, int nargs)
  158. {
  159.     obj_t *old_sp = thread->sp - 2;
  160.     obj_t object = old_sp[1];
  161.     obj_t class = obj_ptr(struct object *, object)->class;
  162.     long double value;
  163.  
  164.     assert(nargs == 1);
  165.  
  166.     if (class == obj_SingleFloatClass)
  167.     value = single_value(object);
  168.     else if (class == obj_DoubleFloatClass)
  169.     value = double_value(object);
  170.     else if (class == obj_ExtendedFloatClass)
  171.     value = extended_value(object);
  172.  
  173.     else 
  174.     lose("I can't float-hash that!");
  175.  
  176.     old_sp[0] = (obj_t)(((unsigned long)MAX_FIXNUM) & (*((int *)(&value))));
  177.             /* Pretend the float is really an integer so we 
  178.            can get at its bits */
  179.  
  180.     old_sp[1] = permanent_state;
  181.     do_return(thread, old_sp, old_sp);
  182. }
  183.  
  184.  
  185.  
  186. /* Printing routine. */
  187.  
  188. static void print_state(obj_t state)
  189. {
  190.     if (state == permanent_state)
  191.     printf("{permanent hash state}");
  192.     else if (state == valid_state)
  193.     printf("{valid hash state}");
  194.     else
  195.     printf("{invalid hash state}");
  196. }
  197.  
  198.  
  199. /* GC routines. */
  200.  
  201. static int scav_state(struct object *o)
  202. {
  203.     return sizeof(struct hash_state);
  204. }
  205.  
  206. static obj_t trans_state(obj_t state)
  207. {
  208.     return transport(state, sizeof(struct hash_state));
  209. }
  210.  
  211. void scavenge_table_roots(void)
  212. {
  213.     scavenge(&obj_HashStateClass);
  214.     scavenge(&permanent_state);
  215.     valid_state = NULL;
  216. }    
  217.  
  218. void table_gc_hook(void)
  219. {
  220.     valid_state = obj_False;
  221. }
  222.  
  223.  
  224. /* Init routines. */
  225.  
  226. void make_table_classes(void)
  227. {
  228.     obj_HashStateClass = make_builtin_class(scav_state, trans_state);
  229. }
  230.  
  231. void init_table_classes(void)
  232. {
  233.     init_builtin_class(obj_HashStateClass, "<hash-state>",
  234.                obj_ObjectClass, NULL);
  235.     def_printer(obj_HashStateClass, print_state);
  236. }
  237.  
  238. void init_table_functions(void)
  239. {
  240.     define_constant("object-hash",
  241.             make_raw_function("object-hash", 1, FALSE, obj_False,
  242.                       FALSE,
  243.                       list2(obj_FixnumClass,
  244.                         obj_HashStateClass),
  245.                       obj_False, dylan_object_hash));
  246.     define_constant("float-hash",
  247.             make_raw_function("float-hash", 1, FALSE, obj_False,
  248.                       FALSE,
  249.                       list2(obj_FixnumClass,
  250.                         obj_HashStateClass),
  251.                       obj_False, dylan_float_hash));
  252.     define_function("state-valid?", list1(obj_HashStateClass), FALSE,
  253.             obj_False, FALSE, obj_BooleanClass, dylan_state_valid_p);
  254.     define_constant("merge-hash-codes",
  255.             make_raw_method("merge-hash-codes",
  256.                     listn(4, obj_FixnumClass,
  257.                       obj_HashStateClass,
  258.                       obj_FixnumClass,
  259.                       obj_HashStateClass),
  260.                     FALSE,
  261.                     list1(pair(symbol("ordered"), obj_False)),
  262.                     FALSE, 
  263.                     list2(obj_FixnumClass,
  264.                       obj_HashStateClass),
  265.                     obj_False, dylan_merge_hash_codes));
  266.  
  267.     permanent_state = alloc(obj_HashStateClass, sizeof(struct hash_state));
  268.     define_constant("$permanent-hash-state", permanent_state);
  269.  
  270.     valid_state = obj_False;
  271. }
  272.